perm filename PLTIT.F4[NEW,LCS] blob sn#170765 filedate 1975-07-28 generic text, type T, neo UTF8
00100	C**** PLTCMD, FILLMS, ROTATE ********
00200		SUBROUTINE PLTCMD
00300	CC	IMPLICIT INTEGER(A-Q,S-Z)
00400		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK /OUTF/JJ
00500		DIMENSION NMS(15),RMOV1(15),RMOV2(15)
00600		COMMON /DL/RSIZ,SAVER,NAME /ALF/INP(72),ML
00700		COMMON R2,JE,CENTR,JB,RJQ(20),JQ(20)
00800		EQUIVALENCE (R5,RJQ(3)),(R6,RJQ(4)),(R7,RJQ(5)),(R4,RJQ(2))
00900		1,(R3,RJQ(1)),(I2,INP(2)),(R8,RJQ(6)),(R9,RJQ(7))
01100	C  BE CAREFUL OF COMMON OVERLAPS WITH NOTWRT,ITMSUB,HOMER, ETC.
01200		F78F(1)='(78F)'
01300		FA5(1)='(A5) '
01400		FA1(1)='(A1) '
01500	
01600		IF(I2.NE.'X')GO TO 1
01700		I2=0
01800		RXC=0
01900		RMOV1(1)='Y'
02000		NAME=0
02100	14	KA=0
02200	3	KA=KA+1
02300		IF(MLL.EQ.0)GO TO 15
02400		K=K-2
02500		MLL=MLL-1
02600		IF(MLL.EQ.0)GO TO 10
02700		GO TO 31
02800	15	TYPE 2,KA
02900		ACCEPT 11,K,MLL,RSPC
03000	C  TYPE LAST NAME, NUMBER  FOR A SERIES, 2ND NUM FOR FIXED SPACE ".
03100	50	IF(K.EQ.' ')GO TO 10
03200		IF(K.EQ.'99')GO TO 140
03300	C  99=BACKUP
03400	31	IF(LOOKD(K))GO TO 56
03500	C JUMP IF FILE FOUND
03600		TYPE 55
03700		GO TO 15
03800	55	FORMAT(' FILE NOT FOUND'/)
03810	11	FORMAT(A5,I,F)
03820	56	IF(MLL.LT.99)GO TO 560
03835		MLL=0 
03840	561	K=K+2
03842	C  TYPE 'AAAAA 99'  TO FIND ALL IN 'AAAAx' SERIES AUTOMATICALLY
03845		MLL=MLL+1
03850		IF(LOOKD(K))GO TO 561
03860	C  KEEPS GOING BACK IF FILES ARE FOUND
03870		K=K-2
04000	560	NMS(KA)=K
04100		IF(MLL.EQ.0)GO TO 5
04200		R8='Y'
04300		IF(RSPC.NE.0)R8=RSPC
04400		GO TO 21
04500	5	TYPE 8
04600		ACCEPT FA5,R8
04700		IF(R8.EQ.'99')GO TO 15
04800		IF(R8.NE.'Y')R8=0
04900		IF(R8.EQ.0)REREAD F78F,R8
05000	C  MOVE NUMBER CAN BE TYPED FOR 'MOVE UP'
05100	21	RMOV1(KA+1)=R8
05200		RMOV2(KA)=R8
05300		GO TO 3
05400	140	KA=KA-1
05500		GO TO 15
05600	
05700	10	KB=KA-1
05800		IF(I3.NE.'G')GO TO 22
05900		RSIZ=1
06000		GO TO 222
06100	22	TYPE 9
06200		ACCEPT F78F,RSIZ,R9
06300	C  SET R9 TO 1 FOR HEAVY STAFF LINES (FOR XGP MAINLY)
06400		IF(RSIZ.EQ.99)GO TO 5
06500		IF(RSIZ.EQ.0)RSIZ=1.
06600		TYPE 550
06700		ACCEPT 11,JJ
06750		IF(JJ.EQ.' ')JJ='PLT'
06800	550	FORMAT(' TYPE OUTPUT NAME - '$)
06900	222	KA=0
07000	
07100	1	IF(NAME.NE.0)GO TO 12
07200		IF(KA.EQ.KB)CALL PLOT(0,0,99)
07300		NAME=NMS(KA+1)
07400		TYPE 111,NAME
07500		RETURN
07600	12	KA=KA+1
07700		NAME=0
07800		R8=0
07900		R2=RSIZ
08000		R3=RSIZ
08100	C  FOR FILLER.  SIZES .LT. 1.6 = EVERY SCAN LINE, .LT. 2.6 = 2, ETC.
08200		R7=0
08300		R5=1
08400		R6=1
08500		IF(RMOV2(KA).NE.'Y')R7=RMOV2(KA)
08600		IF(RMOV1(KA).NE.0)R5=0
08700		IF(RMOV2(KA).NE.0)GO TO 77
08800		IF(R7.EQ.0)RETURN
08810	77	R6=0
08900	2	FORMAT(' TYPE FILE NAME',I2,1X$)
09000	8	FORMAT(' MOVE UP AT END? ',$)
09100	9	FORMAT(' SIZE FACTOR? ',$)
09200	111	FORMAT(1XA5/)
09300		END
09400	
09500	
09600	
09700	C******   CHANGE 3, 4 AND 5 TO JFCL IN DDT WHEN USING DISTORTION.(SEE 'LINES')
09800		SUBROUTINE FILLMS(L,IDAT,R2,CENTR,R6,R7)
09900		COMMON/DL/RSIZ,SAVER,NAME
10000		COMMON/DST/BB,CC/FLM/X(600)
10100		DIMENSION IDAT(1),NX(600)
10150		EQUIVALENCE (NX,X)
10200		COMMON/PLTR/IPLT,RHT,DIS/LL/LL/STF/RR(8),RSTJ2
10300	C MD=DISPLAY   MP=PLOTTER   MX=XGP
10400		DATA M2/2/
10500		DX=DIS
10600		RX=RHT
10700		D=RSTJ2*R6
10800		R=RSTJ2*R7
10900	4	GO TO 1
11000		C=CC
11100		B=BB
11200	C  SAVES IT.  IT WILL RETURN LATER.
11300		BB=B/DIS
11400		CC=1000
11500	1	KK=-2
11600		DO 205 J=1,L
11650		KK=KK+3
11675		KX=KK+2
11700		CALL UNPACK(M,N,IDAT(J))
11900		NX(KX)=2
12000		IF(LL.EQ.3)NX(KX)=3
12100		X(KK)=ROFF((R2+D*M)*DIS)
12200		X(KK+1)=ROFF((CENTR+R*N)*RHT)
12300	3	GO TO 205
12400		X(KK+1)=X(KK+1)*(C-BB*(ABS(X(KK))))
12500	C  FOR DISTORTION
12600	205	CONTINUE
12700		NX(3)=KX
12800		DIS=1.0
12900		RHT=DIS
13000		IF(IPLT)M=RSIZ+.4
13100		IF(M.LE.0)M=1
13200		IF(M.GT.M2)M=M2
13300	C  STOPS DISTORTION IN 'LINES'
13400	2	CALL FILLER(NX,M)
13500		DIS=DX
13600		RHT=RX
13700	5	RETURN
13800	C  NEXT TO RESET DISTORTION FACT.
13900		BB=B
14000		CC=C
14100		RETURN
14200		END
14300	
14400		SUBROUTINE ROTATE(I,L)
14500		DIMENSION I(1)
14600		COMMON R2,JA,CENTR,JB,RJQ(20),JQ(20)/STF/RR(8),RSTJ2
14700		EQUIVALENCE (R6,RJQ(4)),(R7,RJQ(5)),(DEG,RJQ(7))
14800		R7=R7*RSTJ2
14900		R6=R6*RSTJ2
15000		N=I(L)
15100		KNT=601
15200	C  ROTATED DATA IS PUT BACK STARTING AT LOCATION 601.
15300		I(KNT)=N
15400		DO 1 K=L+1,N+L-1
15500		CALL UNPACK(J,M,I(K))
15600		X=J*R6
15700		Y=M*R7
15800		JJ=I(K)/100000000
15900		AX=ATAN2(X,Y)*57.29578
16000		HYP=SQRT(X**2+Y**2)
16100		ROT=DEG+AX
16200		J=ROFF(HYP*COSD(ROT))
16300		M=ROFF(HYP*SIND(ROT))
16400		KNT=KNT+1
16500		IF(J)J=1000-J
16600		IF(M)M=1000-M
16700	1	I(KNT)=M*10000+J+JJ*100000000
16800		L=601
16900		R6=1.
17000		R7=1.
17100		RSTJ2=1.
17200	C  SIZE CHANGES MUST BE MADE BEFORE ROTATION!!!!! ELSE IT DISTORTS.
17300		END
17400	
17500	CC	SUBROUTINE PLOT(J,K,L)
17600	CC	CALL PLOTX(J,K,L)
17700	CC	END
17800	C  TO ROTATE 90 DEG. CHANGE IN DDT AT 1M - 'JUMP J' TO 'JUMP K' AND VS-VS.
17900	
18000	CF	SUBROUTINE PLOT(I,J,K)
18100	CF	COMMON /OUTF/JJ
18200	CF	DIMENSION N(128)
18300	CF	IF(JJ.EQ.-1)GO TO 4
18400	CF	L=1
18500	CF	N(1)=127
18600	CC	IF(JJ.EQ.' ')JJ='PLT'
18700	CF	CALL PUTFIL(JJ)
18800	CF	JJ=-1
18900	CF4	IF(K.EQ.99)GO TO 1
19000	CF	L=L+1
19100	CF	CALL PAC(N(L),I)
19200	CC	N(L)=J+5000+(I+5000)*10000+(K+4)*100000000
19300	C PACKS   PX000Y000
19400	CF3	IF(L.LT.128)RETURN
19500	CF2	CALL FASTOU(N,128)
19600	CF	L=1
19700	CF	RETURN
19800	CF1	N(1)=L
19900	CF	J=N(L)
20000	CF	DO 100 JJ=L,128
20100	CF100	N(JJ)=J
20200	CF	CALL FASTOU(N,128)
20300	CF	CALL FINFIL
20400	CF	JJ=0
20500	CF	CALL EXIT
20600	CF	END
20700	
20800	CF	SUBROUTINE PLOTS(K)
20900	C  DUMMY
21000	CF	END